home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-tassta.adb < prev    next >
Text File  |  1994-05-19  |  43KB  |  1,296 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --                 S Y S T E M . T A S K I N G . S T A G E S                --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.12 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                          --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2,  or (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Compiler_Exceptions;
  27. --  Used for,  Compiler_Exceptions.Notify_Exception
  28.  
  29. --  The following two packages are not part of the GNARL proper.  They
  30. --  provide access to a compiler-specific per-task data area.
  31.  
  32. with System.Task_Soft_Links;
  33. --  Used for, Abort_Defer, Abort_Undefer, Get_TSD_Address
  34. --  These are procedure pointers to non-tasking routines that use
  35. --  task specific data.  In the absense of tasking, these routines
  36. --  refer to global data.  In the presense of tasking, they must be
  37. --  replaced with pointers to task-specific versions.
  38.  
  39. with System.Tasking_Specific_Data;
  40. --  Used for, Create_TSD, Destroy_TSD
  41. --  This package provides initialization routines for task specific data.
  42. --  The GNARL must call these to be sure that all non-tasking
  43. --  Ada constructs will work.
  44.  
  45. with System.Error_Reporting;
  46. --  Used for, Error_Reporting.Assert
  47.  
  48. with System.Tasking.Abortion;
  49. --  Used for, Abortion.Defer_Abortion,
  50. --            Abortion.Undefer_Abortion
  51. --            Abortion.Abort_Dependents
  52. --            Abortion.Abort_To_Level
  53.  
  54. with System.Tasking.Rendezvous;
  55. --  Uses for, Rendezvous.Complete
  56.  
  57. with System.Tasking.Runtime_Types;
  58. --  Used for, Runtime_Types.ATCB_Ptr,
  59. --            Runtime_Types.ATCB_To_ID,
  60. --            Runtime_Types.ID_To_ATCB,
  61. --            Runtime_Types.ATCB_To_Address
  62. --            Runtime_Types."<",
  63. --            Runtime_Types.">=",
  64. --            Runtime_Types."=",
  65. --            Runtime_Types."/=",
  66. --            Runtime_Types.Task_Stage
  67. --            Runtime_Types.Accepting_State
  68. --            Runtime_Types.All_Tasks_List
  69. --            Runtime_Types.Ada_Task_Control_Block
  70. --            Runtime_Types.Task_Error
  71. --            Runtime_Types.ATCB_Init
  72. --            Runtime_Types.Await_Dependents
  73. --            Runtime_Types.Vulnerable_Complete_Activation
  74.  
  75. with System.Task_Memory;
  76. --  Used for, Task_Memory.Low_Level_New,
  77. --            Task_Memory.Unsafe_Low_Level_New,
  78. --            Task_Memory.Low_Level_Free
  79.  
  80. with System.Task_Primitives; use System.Task_Primitives;
  81.  
  82. with Unchecked_Conversion;
  83.  
  84. pragma Elaborate_All (System.Tasking.Rendezvous);
  85. pragma Elaborate_All (System.Tasking.Runtime_Types);
  86. pragma Elaborate_All (System.Task_Primitives);
  87. pragma Elaborate_All (System.Tasking.Abortion);
  88. pragma Elaborate_All (System.Error_Reporting);
  89. pragma Elaborate_All (System.Compiler_Exceptions);
  90. pragma Elaborate_All (System.Task_Memory);
  91.  
  92. pragma Elaborate_All (System.Task_Soft_Links);
  93. --  This must be elaborated first, to prevent its initialization of
  94. --  the global procedure pointers from overwriting the pointers installed
  95. --  by Stages.
  96.  
  97. package body System.Tasking.Stages is
  98.  
  99.    function ID_To_ATCB (ID : Task_ID) return Runtime_Types.ATCB_Ptr
  100.      renames Tasking.Runtime_Types.ID_To_ATCB;
  101.  
  102.    function ATCB_To_ID (Ptr : Runtime_Types.ATCB_Ptr) return Task_ID
  103.      renames Runtime_Types.ATCB_To_ID;
  104.  
  105.    --  Could use "use type" for the following declarations ???
  106.  
  107.    function "=" (L, R : Runtime_Types.ATCB_Ptr) return Boolean
  108.      renames Runtime_Types."=";
  109.  
  110.    function "=" (L, R : Runtime_Types.Task_Stage) return Boolean
  111.      renames Runtime_Types."=";
  112.  
  113.    function ">=" (L, R : Runtime_Types.Task_Stage) return Boolean
  114.      renames Runtime_Types.">=";
  115.  
  116.    function "<" (L, R : Runtime_Types.Task_Stage) return Boolean
  117.      renames Runtime_Types."<";
  118.  
  119.    function "=" (L, R : Runtime_Types.Accepting_State) return Boolean
  120.      renames Runtime_Types."=";
  121.  
  122.    procedure Defer_Abortion renames Abortion.Defer_Abortion;
  123.  
  124.    procedure Undefer_Abortion renames Abortion.Undefer_Abortion;
  125.  
  126.    function Activation_to_ATCB is new
  127.      Unchecked_Conversion (Activation_Chain, Runtime_Types.ATCB_Ptr);
  128.  
  129.    function ATCB_to_Activation is new
  130.      Unchecked_Conversion (Runtime_Types.ATCB_Ptr, Activation_Chain);
  131.  
  132.    -----------------------------
  133.    -- ATCB related operations --
  134.    -----------------------------
  135.  
  136.    --  The TCB contains a variable size array whose dope vector must be
  137.    --  initialized. This is too complex (and changes too much with changes
  138.    --  in the TCB record) to do explicitely, so a record of the correct size
  139.    --  is declared here and copied into the newly allocated storage.
  140.  
  141.    --  Discriminant checking is disabled to prevent the discriminant in the
  142.    --  newly created record from being checked before a legal value is
  143.    --  assigned to it.
  144.  
  145.    --  How is discriminant checking disabled, I see no pragma Suppress ???
  146.  
  147.    procedure Initialize_ATCB
  148.      (T    : Runtime_Types.ATCB_Ptr;
  149.       Init : Runtime_Types.ATCB_Init);
  150.    --  Initialize fields of a TCB and link into global TCB structures
  151.  
  152.    function New_ATCB
  153.      (Init : Runtime_Types.ATCB_Init)
  154.       return Runtime_Types.ATCB_Ptr;
  155.    --  New_ATCB creates a new ATCB using the low level allocation routines
  156.    --  (essentially a protected version of malloc()).  This is done because
  157.    --  the new operator can be changed by the user, and may involve
  158.    --  allocation from pools (which would limit the number of tasks), might
  159.    --  block on insufficiant memory, or might fragment the user's heap
  160.    --  behind his back.
  161.  
  162.    function Unsafe_New_ATCB
  163.      (Init : Runtime_Types.ATCB_Init)
  164.       return Runtime_Types.ATCB_Ptr;
  165.    --  This creates a new ATCB using unprotected low level allocation routines
  166.    --  (essentially malloc()).  This is done for allocating the ATCB for the
  167.    --  initial task, since this must be done before initializing the low
  168.    --  level tasking, and locks (and hence protected Low_Level_New) cannot
  169.    --  be used until it is.
  170.  
  171.    procedure Free_ATCB (T : in out Runtime_Types.ATCB_Ptr);
  172.    --  Release storage of a previously allocated ATCB
  173.  
  174.    -----------------------------
  175.    -- Other Local Subprograms --
  176.    -----------------------------
  177.  
  178.    procedure Task_Wrapper (Arg : System.Address);
  179.    --  Need documentation for this subprogram ???
  180.  
  181.    procedure Terminate_Dependents (ML : Master_ID := Master_ID'First);
  182.    --  Terminate all dependent tasks of given master level
  183.  
  184.    procedure Vulnerable_Complete_Task;
  185.    --  Need documentation for this subprogram ???
  186.  
  187.    procedure Pop_Master;
  188.    --  Need documentation for this subprogram ???
  189.  
  190.    procedure Close_Entries (Target : Task_ID);
  191.    --  Close entries, Purge entry queues called by Task_Stages.Complete.
  192.    --  T.Stage must be Completing before this is c